home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / num_log.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  17.6 KB  |  949 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     Logical operations on number
  24. */
  25. #include "include.h"
  26. #include "num_include.h"
  27. #include "mp.h"
  28. /*
  29.     x : fixnum or bignum (may be not normalized)
  30.     y : integer
  31.    returns
  32.     fixnum or bignum ( not normalized )
  33. */
  34.  
  35. object big_log_op();
  36.  
  37. object
  38. log_op(op)
  39. int (*op)();
  40. {
  41.     object x;
  42.     int    narg, i, j;
  43.     
  44.  
  45.     narg = vs_top - vs_base;
  46.     if (narg < 2) too_few_arguments();
  47.     i = narg;
  48.     while(--i >= 0)
  49.         if (type_of(vs_base[i]) == t_bignum) goto BIG_OP;
  50.     j = fix(vs_base[0]);
  51.     i = 1;
  52.     while (i < narg) {
  53.         j = (*op)(j, fix(vs_base[i]));
  54.         i++;
  55.     }
  56.     return(make_fixnum(j));
  57.  
  58. BIG_OP:
  59.     x = (object)copy_to_big(vs_base[0]);
  60.     vs_push(x);
  61.     i = 1;
  62.     {save_avma;
  63.     while (i < narg) {
  64.         x = (object)big_log_op(x, vs_base[i], op);
  65.         i++;
  66.     }
  67.      restore_avma;}
  68.     x = normalize_big_to_object(x);
  69.     vs_pop;
  70.     return(x);
  71. }
  72. /*
  73.     big_log_op(x, y, op) performs the logical operation op onto
  74.     x and y, and return the result in x destructively.
  75.  
  76.     
  77. */
  78.  
  79. void minimize_lg(x)
  80. GEN x;
  81. {int j,i,lgx = lgef(x);
  82.  GEN u = x+2;
  83.  i = lgx;
  84.  i -= 2;
  85.  while (-- i >= 0)
  86.    { if (*u++) break;
  87.    }
  88.  j = lgx -i -3;
  89.  if (j)
  90.    { GEN v = x+2;
  91.      GEN w = v + j;
  92.      GEN lim = x+lgx;
  93.      while (w<lim)
  94.        {*v++ = *w++;}
  95.      setlgef(x,(i+3));}
  96.  if (i==-1) setsigne(x,0);
  97. }
  98.  
  99.  
  100. /* Fix this.   Should be destructive into x0.
  101.    It is for the benefit of log_op;
  102.    Maybe write an mp version, and then do it.
  103. */   
  104.  
  105. GEN
  106. complementi(x)
  107.      GEN x;
  108. {int l = lgef(x);
  109.  GEN u = cgeti(l);
  110.  unsigned long * v ;
  111.  unsigned long *w ;
  112.  
  113.  MP_START_LOW(w,(unsigned long *)x,l);
  114.  MP_START_LOW(v,(unsigned long *)u,l);
  115.  setlgef(u,l);
  116.  setsigne(u,1);
  117.  l -= MP_CODE_WORDS;
  118.  {unsigned int next=0;
  119.   while (--l >=0)
  120.     { unsigned int last = MP_NEXT_UP(w);
  121.       MP_NEXT_UP(v) = next - last ;
  122.        if (last > next)
  123.      { next -= 1 ;}}
  124.   return u;}}
  125.  
  126. object big_log_op(x0,y0,op)
  127. object x0,y0;
  128.  long (*op)();     
  129. { int leadx,leady;
  130.   int result_length;
  131.   int lgx,lgy;
  132.   GEN x,y,u,up,result;
  133.   save_avma;
  134.   x = MP(x0);
  135.   y = (type_of(y0)==t_bignum ? MP(y0) : stoi(fix(y0)));
  136.   leadx = signe(x);
  137.   lgx=lgef(x);
  138.   if (leadx < 0)
  139.     x = complementi(x);
  140.   else leadx = 0;
  141.  
  142.   lgy = lgef(y);
  143.   leady = signe(y);
  144.   if (leady < 0)
  145.     y=complementi(y);
  146.   else leady = 0;
  147.   result_length = (lgx > lgy ? lgx : lgy);
  148.   u = result = cgeti(result_length);
  149.   setlgef(result,result_length);
  150.   MP_START_LOW(u,u,result_length);
  151.   result_length -= MP_CODE_WORDS;
  152.  
  153.   x += lgx;
  154.   y += lgy;
  155.   lgx -= MP_CODE_WORDS;
  156.   lgy -= MP_CODE_WORDS;
  157.  
  158.   while (--lgx >= 0)
  159.     { if (--lgy >= 0)
  160.     { MP_NEXT_UP(u) = (*op)(MP_NEXT_UP(x),MP_NEXT_UP(y));}
  161.     else MP_NEXT_UP(u) = (*op)(MP_NEXT_UP(x),leady);
  162.       }
  163.   /*  lgx is now 0 */
  164.   while (--lgy >= 0)
  165.     {  MP_NEXT_UP(u) = (*op)(leadx,MP_NEXT_UP(y));}
  166.   {int leadresult = (*op)(leadx,leady);
  167.    if (leadresult < 0)
  168.      { result = complementi(result);
  169.        setsigne(result,-1);}
  170.    else setsigne(result,1);}
  171.   minimize_lg(result);
  172.   restore_avma;
  173.   gcopy_to_big(result,x0);
  174.   return x0;
  175. }
  176.    
  177.  
  178. int
  179. ior_op(i, j)
  180. int    i, j;
  181. {
  182.     return(i | j);
  183. }
  184.  
  185. int
  186. xor_op(i, j)
  187. int    i, j;
  188. {
  189.     return(i ^ j);
  190. }
  191.  
  192. int
  193. and_op(i, j)
  194. int    i, j;
  195. {
  196.     return(i & j);
  197. }
  198.  
  199. int
  200. eqv_op(i, j)
  201. int    i, j;
  202. {
  203.     return(~(i ^ j));
  204. }
  205.  
  206. int
  207. nand_op(i, j)
  208. int    i, j;
  209. {
  210.     return(~(i & j));
  211. }
  212.  
  213. int
  214. nor_op(i, j)
  215. int    i, j;
  216. {
  217.     return(~(i | j));
  218. }
  219.  
  220. int
  221. andc1_op(i, j)
  222. int    i, j;
  223. {
  224.     return((~i) & j);
  225. }
  226.  
  227. int
  228. andc2_op(i, j)
  229. int    i, j;
  230. {
  231.     return(i & (~j));
  232. }
  233.  
  234. int
  235. orc1_op(i, j)
  236. int    i, j;
  237. {
  238.     return((~i) | j);
  239. }
  240.  
  241. int
  242. orc2_op(i, j)
  243. int    i, j;
  244. {
  245.     return(i | (~j));
  246. }
  247.  
  248. b_clr_op(i, j)
  249. int    i, j;
  250. {
  251.     return(0);
  252. }
  253.  
  254. b_set_op(i, j)
  255. int    i, j;
  256. {
  257.     return(-1);
  258. }
  259.  
  260. b_1_op(i, j)
  261. int    i, j;
  262. {
  263.     return(i);
  264. }
  265.  
  266. b_2_op(i, j)
  267. int    i, j;
  268. {
  269.     return(j);
  270. }
  271.  
  272. b_c1_op(i, j)
  273. int    i, j;
  274. {
  275.     return(~i);
  276. }
  277.  
  278. b_c2_op(i, j)
  279. int    i, j;
  280. {
  281.     return(~j);
  282. }
  283.  
  284. int
  285. big_bitp(x, p)
  286. object    x;
  287. int    p;
  288. { GEN u = MP(x);
  289.   int ans ;
  290.   int i = p /32;
  291.   if (signe(u) < 0)
  292.     {  save_avma;
  293.        u = complementi(u);
  294.        restore_avma;
  295.    }
  296.   if (i < lgef(u) -MP_CODE_WORDS)
  297.     { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));}
  298.   else if (big_sign(x) < 0) ans = 1;
  299.   else ans = 0;
  300.   return ans;
  301. }
  302.  
  303. int
  304. fix_bitp(x, p)
  305. object    x;
  306. int    p;
  307. {
  308.     if (p > 30)        /* fix = sign + bit0-30 */
  309.         if (fix(x) < 0)
  310.             return(1);
  311.         else
  312.             return(0);
  313.     return((fix(x) >> p) & 1);
  314. }    
  315.  
  316. int
  317. count_int_bits(x)
  318. int    x;
  319. {
  320.     int    i, count;
  321.  
  322.     count = 0;
  323.     for (i=0; i <= 31; i++) count += ((x >> i) & 1);
  324.     return(count);
  325. }
  326.  
  327. int
  328. count_bits(x)
  329. object    x;
  330. {
  331.     int    i, count, sign;
  332.  
  333.     if (type_of(x) == t_fixnum) {
  334.         i = fix(x);
  335.         if (i < 0) i = ~i;
  336.         count = count_int_bits(i);
  337.     } else if (type_of(x) == t_bignum)
  338.       { save_avma;
  339.         GEN u = MP(x);
  340.         if (signe(u) < 0)
  341.           { u = subsi(-1,u);}
  342.         count = 0;
  343.         {int leng = lgef(u);
  344.          MP_START_LOW(u,u,leng);
  345.          leng -= MP_CODE_WORDS;
  346.          while (--leng >= 0)
  347.            { count += count_int_bits(MP_NEXT_UP(u));}}
  348.         restore_avma;
  349.       }
  350.       else
  351.         FEwrong_type_argument(Sinteger, x);
  352.     return(count);
  353. }
  354.  
  355. /*
  356.     double_shift(h, l, w, hp, lp) shifts the int h & l ( 31 bits)
  357.     w bits to left ( w > 0) or to right ( w < 0).
  358.     result is returned in *hp and *lp.
  359. */
  360.  
  361. object
  362. shift_integer(x, w)
  363. object    x;
  364. int    w;
  365. { GEN u ;
  366.   
  367.   if (type_of(x) == t_fixnum)
  368.     { if (w <= 0)
  369.     { w = -w;
  370.       if (w >= WSIZ) return small_fixnum(0);
  371.       else
  372.     return make_fixnum (fix(x) >> (w));}
  373.       MPOP(return, shifti,stoi(fix(x)),w);
  374.     }
  375.   else
  376.     if (type_of(x) == t_bignum)
  377.       MPOP(return, shifti,MP(x),w);
  378.   else
  379.         FEwrong_type_argument(Sinteger, x);
  380.     
  381. }
  382.   
  383. int
  384. int_bit_length(i)
  385. int    i;
  386. {
  387.     int    count, j;
  388.  
  389.     count = 0;
  390.     for (j = 0; j <= 31 ; j++)
  391.         if (((i >> j) & 1) == 1) count = j + 1;
  392.     return(count);
  393. }
  394.  
  395.  
  396.  
  397. Llogior()
  398. {
  399.     object  x;
  400.     int    narg, i;
  401.     int    ior_op();
  402.  
  403.     narg = vs_top - vs_base;
  404.     for (i = 0; i < narg; i++)
  405.         check_type_integer(&vs_base[i]);
  406.     if (narg == 0) {
  407.         vs_top = vs_base;
  408.         vs_push(small_fixnum(0));
  409.         return;
  410.     }
  411.     if (narg == 1)
  412.         return;
  413.     x = log_op(ior_op);
  414.     vs_top = vs_base;
  415.     vs_push(x);
  416. }
  417.  
  418. Llogxor()
  419. {
  420.     object  x;
  421.     int    narg, i;
  422.     int    xor_op();
  423.  
  424.     narg = vs_top - vs_base;
  425.     for (i = 0; i < narg; i++)
  426.         check_type_integer(&vs_base[i]);
  427.     if (narg == 0) {
  428.         vs_top = vs_base;
  429.         vs_push(small_fixnum(0));
  430.         return;
  431.     }
  432.     if (narg == 1) return;
  433.     x = log_op(xor_op);
  434.     vs_top = vs_base;
  435.     vs_push(x);
  436. }
  437.  
  438. Llogand()
  439. {
  440.     object  x;
  441.     int    narg, i;
  442.     int    and_op();
  443.  
  444.     narg = vs_top - vs_base;
  445.     for (i = 0; i < narg; i++)
  446.         check_type_integer(&vs_base[i]);
  447.     if (narg == 0) {
  448.         vs_top = vs_base;
  449.         vs_push(small_fixnum(-1));
  450.         return;
  451.     }
  452.     if (narg == 1) return;
  453.     x = log_op(and_op);
  454.     vs_top = vs_base;
  455.     vs_push(x);
  456. }
  457.  
  458. Llogeqv()
  459. {
  460.     object  x;
  461.     int    narg, i;
  462.     int    eqv_op();
  463.  
  464.     narg = vs_top - vs_base;
  465.     for (i = 0; i < narg; i++)
  466.         check_type_integer(&vs_base[i]);
  467.     if (narg == 0) {
  468.         vs_top = vs_base;
  469.         vs_push(small_fixnum(-1));
  470.         return;
  471.     }
  472.     if (narg == 1) return;
  473.     x = log_op(eqv_op);
  474.     vs_top = vs_base;
  475.     vs_push(x);
  476. }
  477.  
  478. Lboole()
  479. {
  480.     object  x;
  481.     object    o, r;
  482.     int    (*op)();
  483.  
  484.     check_arg(3);
  485.     check_type_integer(&vs_base[0]);
  486.     check_type_integer(&vs_base[1]);
  487.     check_type_integer(&vs_base[2]);
  488.     o = vs_base[0];
  489.     switch(fixint(o)) {
  490.         case BOOLCLR:    op = b_clr_op;    break;
  491.         case BOOLSET:    op = b_set_op;    break;
  492.         case BOOL1:    op = b_1_op;    break;
  493.         case BOOL2:    op = b_2_op;    break;
  494.         case BOOLC1:    op = b_c1_op;    break;
  495.         case BOOLC2:    op = b_c2_op;    break;
  496.         case BOOLAND:    op = and_op;    break;
  497.         case BOOLIOR:    op = ior_op;    break;
  498.         case BOOLXOR:    op = xor_op;    break;
  499.         case BOOLEQV:    op = eqv_op;    break;
  500.         case BOOLNAND:    op = nand_op;    break;
  501.         case BOOLNOR:    op = nor_op;    break;
  502.         case BOOLANDC1:    op = andc1_op;    break;
  503.         case BOOLANDC2:    op = andc2_op;    break;
  504.         case BOOLORC1:    op = orc1_op;    break;
  505.         case BOOLORC2:    op = orc2_op;    break;
  506.         default:
  507.             FEerror("~S is an invalid logical operator.",
  508.                 1, o);
  509.     }
  510.     vs_base++;
  511.     x = log_op(op);
  512.     vs_base--;
  513.     vs_top = vs_base;
  514.     vs_push(x);
  515. }
  516.  
  517. Llogbitp()
  518. {
  519.     object    x, p;
  520.     int    i;
  521.  
  522.     check_arg(2);
  523.     check_type_integer(&vs_base[0]);
  524.     check_type_integer(&vs_base[1]);
  525.     p = vs_base[0];
  526.     x = vs_base[1];
  527.     if (type_of(p) == t_fixnum)
  528.         if (type_of(x) == t_fixnum)
  529.             i = fix_bitp(x, fix(p));
  530.         else
  531.             i = big_bitp(x, fix(p));
  532.     else if (big_sign(p) < 0)
  533.             i = 0;
  534.         /*
  535.            bit position represented by bignum is out of
  536.            our address space. So, result is returned
  537.            according to sign of integer.
  538.         */
  539.  
  540.     else if (type_of(x) == t_fixnum)
  541.         if (fix(x) < 0)
  542.             i = 1;
  543.         else
  544.             i = 0;
  545.     else if (big_sign(x) < 0)
  546.             i = 1;
  547.         else
  548.             i = 0;
  549.  
  550.     vs_top = vs_base;
  551.     if (i)
  552.         vs_push(Ct);
  553.     else
  554.         vs_push(Cnil);
  555. }
  556.  
  557. Lash()
  558. {
  559.     object    r, x, y;
  560.     int    w, sign_x;
  561.  
  562.     check_arg(2);
  563.         check_type_integer(&vs_base[0]);
  564.     check_type_integer(&vs_base[1]);
  565.     x = vs_base[0];
  566.     y = vs_base[1];
  567.     if (type_of(y) == t_fixnum) {
  568.         w = fix(y);
  569.         r = shift_integer(x, w);
  570.     } else if (type_of(y) == t_bignum)
  571.         goto LARGE_SHIFT;
  572.     else
  573.         ;
  574.     goto BYE;
  575.  
  576.     /*
  577.     bit position represented by bignum is probably
  578.     out of our address space. So, result is returned
  579.     according to sign of integer.
  580.     */
  581. LARGE_SHIFT:
  582.     if (type_of(x) == t_fixnum)
  583.         if (fix(x) > 0)
  584.             sign_x = 1;
  585.         else if (fix(x) == 0)
  586.             sign_x = 0;
  587.         else
  588.             sign_x = -1;
  589.     else
  590.         sign_x = big_sign(x);
  591.     if (big_sign(y) < 0)
  592.         if (sign_x < 0)
  593.             r = small_fixnum(-1);
  594.         else
  595.             r = small_fixnum(0);
  596.     else if (sign_x == 0)
  597.         r = small_fixnum(0);
  598.     else
  599.         FEerror("Insufficient memory.", 0);
  600.  
  601. BYE:
  602.     vs_top = vs_base;
  603.     vs_push(r);
  604. }
  605.  
  606. Llogcount()
  607. {
  608.     object    x;
  609.     int    i;
  610.  
  611.     check_arg(1);
  612.     check_type_integer(&vs_base[0]);
  613.     x = vs_base[0];
  614.     i = count_bits(x);
  615.     vs_top = vs_base;
  616.     vs_push(make_fixnum(i));
  617. }
  618.  
  619. Linteger_length()
  620. {
  621.     object    x;
  622.     int    count, cell, i;
  623.  
  624.     check_arg(1);
  625.     x = vs_base[0];
  626.     if (type_of(x) == t_fixnum) {
  627.         i = fix(x);
  628.         if (i < 0) i = ~i;
  629.         count = int_bit_length(i);
  630.     } else if (type_of(x) == t_bignum) 
  631.       { GEN w,u = MP(x);
  632.         int l = lg(u);
  633.         ulong high;
  634.         w = u;
  635.         MP_START_HIGH(u,u,l);
  636.         high = MP_NEXT_DOWN(u);
  637.         count = int_bit_length(high) ;
  638.         
  639.         l -= MP_CODE_WORDS;
  640.         
  641.         if (signe(w) < 0 &&
  642.         high == (1 << (count -1)))
  643.           /* in the case of -(1<< n)
  644.          it is one less */
  645.           { int ll = l;
  646.         int nzero = 0;
  647.         while (--ll > 0)
  648.           { if (MP_NEXT_DOWN(u))
  649.               {nzero= 1; break;}}
  650.         if (nzero == 0) --count ;}
  651.         
  652.         count +=               32* (l - 1);
  653.       }
  654.     else
  655.               FEwrong_type_argument(Sinteger, x);
  656.     vs_top = vs_base;
  657.     vs_push(make_fixnum(count));
  658. }
  659.  
  660. #define W_SIZE (8*sizeof(int))
  661. object
  662. bitand(a,b,c)
  663.      object a,b,c;
  664. { int d= a->bv.bv_fillp;
  665.   int *ap,*bp,*cp;
  666.   d=(d+W_SIZE-1)/W_SIZE;
  667.   ap= (int *)(a->bv.bv_self);
  668.   bp= (int *)(b->bv.bv_self);
  669.   cp= (int *)(c->bv.bv_self);
  670.   while (--d >= 0)
  671.     { *cp++ = *bp++ & *ap++;
  672.     }
  673.   return c;
  674. }
  675.  
  676. object
  677. bitior(a,b,c)
  678.      object a,b,c;
  679. { int *ap,*cp,*bp, d= a->bv.bv_fillp;
  680.   d=(d+W_SIZE-1)/W_SIZE;
  681.    ap= (int *)((a->bv.bv_self));
  682.    bp= (int *)(b->bv.bv_self);
  683.    cp= (int *)(c->bv.bv_self);
  684.   while (--d >= 0)
  685.     { *cp++ = *bp++ | *ap++;
  686.     }
  687.   return c;
  688. }
  689.  
  690. /* Note in order to be equal we assume that the part above the
  691.    fill pointer is 0 up to the next word */
  692.  
  693. bvequal(a,b)
  694.      object a,b;
  695. { int *ap,*bp, d= a->bv.bv_fillp;
  696.   d=(d+W_SIZE-1)/W_SIZE;
  697.  ap= (int *)(a->bv.bv_self);
  698.  bp= (int *)(b->bv.bv_self);
  699.   while (--d >= 0)
  700.     { if (*ap++ != *bp++) return 1;
  701.     }
  702.   return 0;
  703. }
  704.  
  705.   
  706.  
  707.  
  708. init_num_log()
  709. {
  710.     int siLbit_array_op();
  711.  
  712.     make_constant("BOOLE-CLR", make_fixnum(BOOLCLR));
  713.     make_constant("BOOLE-SET", make_fixnum(BOOLSET));
  714.     make_constant("BOOLE-1", make_fixnum(BOOL1));
  715.     make_constant("BOOLE-2", make_fixnum(BOOL2));
  716.     make_constant("BOOLE-C1", make_fixnum(BOOLC1));
  717.     make_constant("BOOLE-C2", make_fixnum(BOOLC2));
  718.     make_constant("BOOLE-AND", make_fixnum(BOOLAND));
  719.     make_constant("BOOLE-IOR", make_fixnum(BOOLIOR));
  720.     make_constant("BOOLE-XOR", make_fixnum(BOOLXOR));
  721.     make_constant("BOOLE-EQV", make_fixnum(BOOLEQV));
  722.     make_constant("BOOLE-NAND", make_fixnum(BOOLNAND));
  723.     make_constant("BOOLE-NOR", make_fixnum(BOOLNOR));
  724.     make_constant("BOOLE-ANDC1", make_fixnum(BOOLANDC1));
  725.     make_constant("BOOLE-ANDC2", make_fixnum(BOOLANDC2));
  726.     make_constant("BOOLE-ORC1", make_fixnum(BOOLORC1));
  727.     make_constant("BOOLE-ORC2", make_fixnum(BOOLORC2));
  728.  
  729.     make_function("LOGIOR", Llogior);
  730.     make_function("LOGXOR", Llogxor);
  731.     make_function("LOGAND", Llogand);
  732.     make_function("LOGEQV", Llogeqv);
  733.     make_function("BOOLE", Lboole);
  734.     make_function("LOGBITP", Llogbitp);
  735.     make_function("ASH", Lash);
  736.     make_function("LOGCOUNT", Llogcount);
  737.     make_function("INTEGER-LENGTH", Linteger_length);
  738.  
  739.     Sbit = make_ordinary("BIT");
  740.     make_si_function("BIT-ARRAY-OP", siLbit_array_op);
  741. }
  742.  
  743.  
  744. siLbit_array_op()
  745. {
  746.     int i, j, n, d;
  747.     object  o, x, y, r, r0;
  748.     int (*op)();
  749.     bool replace = FALSE;
  750.     int xi, yi, ri;
  751.     char *xp, *yp, *rp;
  752.     int xo, yo, ro;
  753.     object *base = vs_base;
  754.  
  755.     check_arg(4);
  756.     o = vs_base[0];
  757.     x = vs_base[1];
  758.     y = vs_base[2];
  759.     r = vs_base[3];
  760.     if (type_of(x) == t_bitvector) {
  761.         d = x->bv.bv_dim;
  762.         xp = x->bv.bv_self;
  763.         xo = x->bv.bv_offset;
  764.         if (type_of(y) != t_bitvector)
  765.             goto ERROR;
  766.         if (d != y->bv.bv_dim)
  767.             goto ERROR;
  768.         yp = y->bv.bv_self;
  769.         yo = y->bv.bv_offset;
  770.         if (r == Ct)
  771.             r = x;
  772.         if (r != Cnil) {
  773.             if (type_of(r) != t_bitvector)
  774.                 goto ERROR;
  775.             if (r->bv.bv_dim != d)
  776.                 goto ERROR;
  777.             i = (r->bv.bv_self - xp)*8 + (r->bv.bv_offset - xo);
  778.             if (i > 0 && i < d || i < 0 && -i < d) {
  779.                 r0 = r;
  780.                 r = Cnil;
  781.                 replace = TRUE;
  782.                 goto L1;
  783.             }
  784.             i = (r->bv.bv_self - yp)*8 + (r->bv.bv_offset - yo);
  785.             if (i > 0 && i < d || i < 0 && -i < d) {
  786.                 r0 = r;
  787.                 r = Cnil;
  788.                 replace = TRUE;
  789.             }
  790.         }
  791.     L1:
  792.         if (r == Cnil) {
  793.             vs_base = vs_top;
  794.             vs_push(Sbit);
  795.             vs_push(make_fixnum(d));
  796.             vs_push(Cnil);
  797.             vs_push(Cnil);
  798.             vs_push(Cnil);
  799.             vs_push(Cnil);
  800.             vs_push(Cnil);
  801.             siLmake_vector();
  802.             r = vs_base[0];
  803.         }
  804.     } else {
  805.         if (type_of(x) != t_array)
  806.             goto ERROR;
  807.         if ((enum aelttype)x->a.a_elttype != aet_bit)
  808.             goto ERROR;
  809.         d = x->a.a_dim;
  810.         xp = x->bv.bv_self;
  811.         xo = x->bv.bv_offset;
  812.         if (type_of(y) != t_array)
  813.             goto ERROR;
  814.         if ((enum aelttype)y->a.a_elttype != aet_bit)
  815.             goto ERROR;
  816.         if (x->a.a_rank != y->a.a_rank)
  817.             goto ERROR;
  818.         yp = y->bv.bv_self;
  819.         yo = y->bv.bv_offset;
  820.         for (i = 0;  i < x->a.a_rank;  i++)
  821.             if (x->a.a_dims[i] != y->a.a_dims[i])
  822.                 goto ERROR;
  823.         if (r == Ct)
  824.             r = x;
  825.         if (r != Cnil) {
  826.             if (type_of(r) != t_array)
  827.                 goto ERROR;
  828.             if ((enum aelttype)r->a.a_elttype != aet_bit)
  829.                 goto ERROR;
  830.             if (r->a.a_rank != x->a.a_rank)
  831.                 goto ERROR;
  832.             for (i = 0;  i < x->a.a_rank;  i++)
  833.                 if (r->a.a_dims[i] != x->a.a_dims[i])
  834.                     goto ERROR;
  835.             i = (r->bv.bv_self - xp)*8 + (r->bv.bv_offset - xo);
  836.             if (i > 0 && i < d || i < 0 && -i < d) {
  837.                 r0 = r;
  838.                 r = Cnil;
  839.                 replace = TRUE;
  840.                 goto L2;
  841.             } 
  842.             i = (r->bv.bv_self - yp)*8 + (r->bv.bv_offset - yo);
  843.             if (i > 0 && i < d || i < 0 && -i < d) {
  844.                 r0 = r;
  845.                 r = Cnil;
  846.                 replace = TRUE;
  847.             }
  848.         }
  849.     L2:
  850.         if (r == Cnil) {
  851.             vs_base = vs_top;
  852.             vs_push(Sbit);
  853.             vs_push(Cnil);
  854.             vs_push(Cnil);
  855.             vs_push(Cnil);
  856.             vs_push(Cnil);
  857.             vs_push(small_fixnum(0));
  858.             for (i = 0;  i < x->a.a_rank;  i++)
  859.                 vs_push(make_fixnum(x->a.a_dims[i]));
  860.             siLmake_pure_array();
  861.             r = vs_base[0];
  862.         }
  863.     }
  864.     rp = r->bv.bv_self;
  865.     ro = r->bv.bv_offset;
  866.     switch(fixint(o)) {
  867.         case BOOLCLR:    op = b_clr_op;    break;
  868.         case BOOLSET:    op = b_set_op;    break;
  869.         case BOOL1:    op = b_1_op;    break;
  870.         case BOOL2:    op = b_2_op;    break;
  871.         case BOOLC1:    op = b_c1_op;    break;
  872.         case BOOLC2:    op = b_c2_op;    break;
  873.         case BOOLAND:    op = and_op;    break;
  874.         case BOOLIOR:    op = ior_op;    break;
  875.         case BOOLXOR:    op = xor_op;    break;
  876.         case BOOLEQV:    op = eqv_op;    break;
  877.         case BOOLNAND:    op = nand_op;    break;
  878.         case BOOLNOR:    op = nor_op;    break;
  879.         case BOOLANDC1:    op = andc1_op;    break;
  880.         case BOOLANDC2:    op = andc2_op;    break;
  881.         case BOOLORC1:    op = orc1_op;    break;
  882.         case BOOLORC2:    op = orc2_op;    break;
  883.         default:
  884.             FEerror("~S is an invalid logical operator.", 1, o);
  885.     }
  886.  
  887. #define    set_high(place, nbits, value) \
  888.     ((place)=((place)&~(-0400>>(nbits))|(value)&(-0400>>(nbits))))
  889.  
  890. #define    set_low(place, nbits, value) \
  891.     ((place)=((place)&(-0400>>(8-(nbits)))|(value)&~(-0400>>(8-(nbits)))))
  892.  
  893. #define    extract_byte(integer, pointer, index, offset) \
  894.     (integer) = (pointer)[(index)+1] & 0377; \
  895.     (integer) = ((pointer)[index]<<(offset))|((integer)>>(8-(offset)))
  896.  
  897. #define    store_byte(pointer, index, offset, value) \
  898.     set_low((pointer)[index], 8-(offset), (value)>>(offset)); \
  899.     set_high((pointer)[(index)+1], offset, (value)<<(8-(offset)))
  900.  
  901.     if (xo == 0 && yo == 0 && ro == 0) {
  902.         for (n = d/8, i = 0;  i < n;  i++)
  903.             rp[i] = (*op)(xp[i], yp[i]);
  904.         if ((j = d%8) > 0)
  905.             set_high(rp[n], j, (*op)(xp[n], yp[n]));
  906.         if (!replace) {
  907.             vs_top = vs_base = base;
  908.             vs_push(r);
  909.             return;
  910.         }
  911.     } else {
  912.         for (n = d/8, i = 0;  i <= n;  i++) {
  913.             extract_byte(xi, xp, i, xo);
  914.             extract_byte(yi, yp, i, yo);
  915.             if (i == n) {
  916.                 if ((j = d%8) == 0)
  917.                     break;
  918.                 extract_byte(ri, rp, n, ro);
  919.                 set_high(ri, j, (*op)(xi, yi));
  920.             } else
  921.                 ri = (*op)(xi, yi);
  922.             store_byte(rp, i, ro, ri);
  923.         }
  924.         if (!replace) {
  925.             vs_top = vs_base = base;
  926.             vs_push(r);
  927.             return;
  928.         }
  929.     }
  930.     rp = r0->bv.bv_self;
  931.     ro = r0->bv.bv_offset;
  932.     for (n = d/8, i = 0;  i <= n;  i++) {
  933.         if (i == n) {
  934.             if ((j = d%8) == 0)
  935.                 break;
  936.             extract_byte(ri, rp, n, ro);
  937.             set_high(ri, j, r->bv.bv_self[n]);
  938.         } else
  939.             ri = r->bv.bv_self[i];
  940.         store_byte(rp, i, ro, ri);
  941.     }
  942.     vs_top = vs_base = base;
  943.     vs_push(r0);
  944.     return;
  945.  
  946. ERROR:
  947.     FEerror("Illegal arguments for bit-array operation.", 0);
  948. }
  949.